home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / tclMode.tcl < prev   
Encoding:
Text File  |  1999-05-03  |  34.1 KB  |  1,090 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "tclMode.tcl"
  6.  #                                    created: 5/4/97 {9:31:10 pm} 
  7.  #                                last update: 05/03/1999 {18:39:51 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1999 Vince Darley
  15.  #  
  16.  # Three procs from original: Tcl::DblClick listArray, getVarValue
  17.  #    
  18.  # Adds support for Tk, Itcl keywords and completions, plus 
  19.  # numerous fixes, improvements and integration with Vince's
  20.  # Additions.
  21.  # ###################################################################
  22.  ##
  23.  
  24. alpha::mode Tcl 1.7.3 tclMenu {*.tcl *.itcl *.itk} {
  25.     tclMenu electricTab electricReturn electricBraces
  26. } {
  27.     addMenu tclMenu "•269" "Tcl"
  28.     set unixMode(wish) {Tcl}
  29.     set unixMode(tclsh) {Tcl}
  30.     ensureset tclshSig "WIsH"
  31.     ensureset evaluateRemotely 0
  32.     trace variable evaluateRemotely w evaluateRemoteSynchronise
  33. } maintainer {
  34.     "Vince Darley" darley@fas.harvard.edu <http://www.fas.harvard.edu/~darley/>
  35. } uninstall this-file help {
  36.     This mode is for editing Tcl code.  You can edit code for internal
  37.     use with Alpha, or use Alpha as an external editor for code destined
  38.     for use with Tcl and Tk interpreters --- Sun distributes the Wish
  39.     application and a tcl-tk browser plugin.
  40.     
  41.     You can 'evaluate' a procedure (or any Tcl code for that matter) to 
  42.     make changes on the fly.  If you select 'Evaluate Remotely' in the 
  43.     tcl-tk submenu, then such actions will actually send the code
  44.     to a separately running Wish application to be evaluated.
  45. }
  46.  
  47.  
  48. proc tclMenu {} {}
  49.  
  50. # ◊◊◊◊ menu and prefs ◊◊◊◊ #
  51. # The menu.
  52. proc menu::buildtclMenu {} {
  53.     global tclMenu evaluateRemotely
  54.     set ma [list \
  55.       "/Levaluate" "/-<UswitchToTclsh" \
  56.       [list Menu -n "tcl-tk" -p tcltk::menuProc [list \
  57.       "![lindex {{ } •} $evaluateRemotely]evaluateRemotely" \
  58.       executeCommand]] \
  59.       "(-" "/L<O<BreloadProc" "/I<O<BreformatProc" \
  60.       "/Z<O<BtraceThisProc" "/Z<O<UtraceTclProc…" \
  61.       "/D<O<UdumpTraces" "(-" "rebuildTclIndices" "(-" \
  62.       "<U/PfindProcDefinition…" "/Q<IquickFindProc…" "getVarValue…" \
  63.       "insertMenuCodes…" "insertBindingCodes…" "/4<BaddRemoveDollars" \
  64.       "/3<BinsertDivider" "/8<I<BsurroundWithBullets"]
  65.     return [list build $ma Tcl::MenuProc "" $tclMenu]
  66. }
  67. menu::buildProc tclMenu menu::buildtclMenu
  68. menu::buildSome tclMenu
  69.  
  70. newPref v prefixString {# } Tcl
  71. newPref f wordWrap {0} Tcl
  72. newPref v funcExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  73. newPref v parseExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  74. newPref v wordBreak {(\$)?[\w:_]+} Tcl
  75. newPref v wordBreakPreface {([^\w:_\$]|.\$)} Tcl
  76. newPref f autoMark 0 Tcl
  77. newPref v stringColor green Tcl
  78. newPref v commentColor red Tcl
  79. newPref v keywordColor blue Tcl
  80. # Colour to use for Alpha's built in commands
  81. newPref v alphaKeyWordColor    none Tcl stringColorProc
  82. # Colour Tk commands
  83. newPref f recogniseTk 1 Tcl Tcl::_updateKeywords
  84. # Colour [incr Tcl] commands
  85. newPref f recogniseItcl 1 Tcl Tcl::_updateKeywords
  86. # Recognise and colour some common procedures 'lunion' etc.
  87. newPref f recognisePseudoTcl 1 Tcl Tcl::_updateKeywords
  88. # Indentation scheme for lines following one ending in a backslash
  89. newPref v indentSlashEndLines 1 Tcl "" indent::amounts varindex
  90. # Mark files structurally, recognising the special comments
  91. # entered by 'ctrl-3'
  92. newPref f structuralMarks 0 Tcl
  93. set Tcl::startPara {^(.*\{)?[ \t]*(#|$)}
  94. set Tcl::endPara {^(.*\})?[ \t]*(#|$)}
  95. set Tcl::commentRegexp {^[ \t]*#}
  96.  
  97. ## 
  98.  # -------------------------------------------------------------------------
  99.  # 
  100.  # "Tcl::_updateKeywords" --
  101.  # 
  102.  #  This proc now includes support for optional separate colorization of 
  103.  #  alpha commands. To use, set 'alphaKeyWordColor' to something other than 
  104.  #  'none' in the Tcl Mode Preferences dialog. -trf
  105.  # -------------------------------------------------------------------------
  106.  ##
  107. proc Tcl::_updateKeywords {args} {
  108.     set tclKeyWords {
  109.     after append array auto_execok auto_load auto_mkindex 
  110.     auto_reset beep binary break case catch cd clock close concat 
  111.     continue echo eof error eval exit expr fblocked fconfigure 
  112.     fcopy file fileevent flush for foreach format gets glob global 
  113.     history if incr info interp join lappend lindex linsert list 
  114.     llength load lrange lreplace ls lsearch lsort namespace open 
  115.     package pid pkg_mkIndex proc puts pwd read regexp regsub 
  116.     rename resource return scan seek set socket source split 
  117.     string subst switch tclMacPkgSearch tclPkgSetup tclPkgUnknown 
  118.     tell time trace unknown unset update uplevel upvar variable 
  119.     vwait while scancontext else elseif default
  120.     }
  121.     
  122.     set alphaKeyWords {
  123.     abortEm abbrev addAlphaChars addMenuItem addDef addArrDef 
  124.     AEBuild alertnote alphaHelp ascii askyesno backColor backSpace 
  125.     backwardChar backwardCharSelect backwardDeleteWord 
  126.     backwardWord balance beginningBufferSelect beginningLineSelect 
  127.     beginningOfBuffer beginningOfLine Bind blink breakIntoLines 
  128.     bringToFront buttonAlert capitalizeRegion capitalizeWord 
  129.     centerRedraw clear closeAll colors colorTriple copy cp 
  130.     createTagFile createTMark currentPosition cut decToHex 
  131.     deleteChar deleteMenuItem deleteModeBindings deleteSelection 
  132.     deleteWord describeBinding deleteText dialog dirs display 
  133.     displayMode dosc downcaseRegion downcaseWord dumpColors 
  134.     dumpMacro edit enableMenuItem endBufferSelect endKeyboardMacro 
  135.     endLineSelect endOfBuffer endOfLine enterSelection evaluate
  136.     eventHandler exchangePointAndMark execAbbrev execute 
  137.     executeKeyboardMacro fileInfo fileRemove find findAgain 
  138.     findAgainBackward findFile findInNextFile findTag float 
  139.     floatShowHide forwardChar forwardCharSelect forwardWord 
  140.     freeMem get_directory getAscii getChar getModifiers getColors 
  141.     getfile getFileInfo getGeometry getline getMainDevice getMark 
  142.     getNamedMarks getPathName getPos getScrap getSelect getText 
  143.     getTMarks getWinInfo goto gotoMark gotoTMark hexToDec icon 
  144.     icURL icGetPref icOpen insertAscii insertColorEscape 
  145.     insertFile insertMenu insertPathName insertText insertToTop 
  146.     isearch iterationCount jumpToRegister keyAscii keyCode 
  147.     killLine killWindow largestPrefix launch lineStart 
  148.     listBindings listpick lookAt markHilite markMenuItem 
  149.     matchBrace matchIt maxPos Menu message mkdir mousePos 
  150.     moveInsertionHere moveFile moveWin mtime nameFromAppl new 
  151.     nextLine nextLineSelect nextLineStart nextSentence nextWindow 
  152.     now oneSpace openLine otherPane pageBack pageForward pageSetup 
  153.     paste pointToRegister popd posToRowCol prefixChar previousLine 
  154.     prevLineSelect prevSentence prevWindow print processes prompt 
  155.     pushd putfile putScrap quit rectMarkHilite redo 
  156.     regModeKeywords removeArrDef removeDef removeFile removeMark 
  157.     removeMenu removeTMark replace replaceAll replace&FindAgain 
  158.     replaceString replaceText restoreVars revert rmdir rowColToPos 
  159.     rsearch save saveAs saveVars scrollDownLine scrollLeftCol 
  160.     scrollRightCol scrollUpLine search searchString select selEnd 
  161.     sendOpenEvent sendToBack setFileInfo setFontsTabs setMark 
  162.     setNamedMark setWinInfo shell shiftLeftRegion shiftRightRegion 
  163.     sizeWin sortMarks spacesToTabs specToPathName splitWindow 
  164.     startEscape startKeyboardMacro statusPrompt substituteVars 
  165.     switchTo tab tabsToSpaces tclFileCompletion tclResult 
  166.     thinkReference ticks toggleScrollbar traceFunc unascii unBind 
  167.     undo unfloat upcaseRegion upcaseWord version watchCursor wc 
  168.     winNames wrap wrapText xtclcmd yank zapInvisibles zoom
  169.     }
  170.     
  171.     set tkKeyWords {
  172.     bind bindtags button canvas checkbutton console destroy entry event focus 
  173.     font frame grab grid image menubutton pack place radiobutton raise 
  174.     scale scrollbar text tk tkwait toplevel winfo wm label listbox
  175.     menu
  176.     }
  177.     
  178.     set itclKeyWords {
  179.     @scope body class code common component configbody constructor define 
  180.     destructor hull 
  181.     import inherit itcl itk itk_component itk_initialize itk_interior 
  182.     itk_option iwidgets keep method private protected 
  183.     public
  184.     }
  185.     global TclmodeVars
  186.     # add Tk keywords
  187.     if {$TclmodeVars(recogniseTk)} {
  188.     set tclKeyWords [concat $tclKeyWords $tkKeyWords]
  189.     }
  190.     # add the [incr tcl] keywords
  191.     if {$TclmodeVars(recogniseItcl)} {
  192.     set tclKeyWords [concat $tclKeyWords $itclKeyWords]
  193.     }
  194.     if {$TclmodeVars(recognisePseudoTcl)} {
  195.     set tclKeyWords [concat $tclKeyWords "lunion lreverse lremove lunique car"]
  196.     }
  197.     # add user extras
  198.     global Tclwords
  199.     if {[info exists Tclwords]} {
  200.     set tclKeyWords [concat $tclKeyWords $Tclwords]
  201.     }
  202.     global Tclcmds
  203.     set Tclcmds { append array catch close concat continue elseif error
  204.     for foreach format lindex llength lrange lreplace lsearch lsort regexp 
  205.     regsub rename return string switch while }
  206.     if {$TclmodeVars(recogniseTk)} {
  207.     append Tclcmds {
  208.         tkButtonDown tkButtonEnter tkButtonInvoke tkButtonLeave 
  209.         tkButtonUp tkCancelRepeat tkCheckRadioInvoke tkDarken 
  210.         tkEntryAutoScan tkEntryBackspace tkEntryButton1 
  211.         tkEntryClosestGap tkEntryInsert tkEntryKeySelect 
  212.         tkEntryMouseSelect tkEntryNextWord tkEntryPaste 
  213.         tkEntryPreviousWord tkEntrySeeInsert tkEntrySetCursor 
  214.         tkEntryTranspose tkEventMotifBindings tkFDGetFileTypes 
  215.         tkFirstMenu tkFocusGroup_BindIn tkFocusGroup_BindOut 
  216.         tkFocusGroup_Create tkFocusGroup_Destroy tkFocusGroup_In 
  217.         tkFocusGroup_Out tkFocusOK tkListboxAutoScan 
  218.         tkListboxBeginExtend tkListboxBeginSelect tkListboxBeginToggle 
  219.         tkListboxCancel tkListboxDataExtend tkListboxExtendUpDown 
  220.         tkListboxMotion tkListboxSelectAll tkListboxUpDown tkMbButtonUp 
  221.         tkMbEnter tkMbLeave tkMbMotion tkMbPost tkMenuButtonDown 
  222.         tkMenuDownArrow tkMenuDup tkMenuEscape tkMenuFind 
  223.         tkMenuFindName tkMenuFirstEntry tkMenuInvoke tkMenuLeave 
  224.         tkMenuLeftArrow tkMenuMotion tkMenuNextEntry tkMenuNextMenu 
  225.         tkMenuRightArrow tkMenuUnpost tkMenuUpArrow tkMessageBox 
  226.         tkPostOverPoint tkRecolorTree tkRestoreOldGrab tkSaveGrabInfo 
  227.         tkScaleActivate tkScaleButton2Down tkScaleButtonDown 
  228.         tkScaleControlPress tkScaleDrag tkScaleEndDrag tkScaleIncrement 
  229.         tkScreenChanged tkScrollButton2Down tkScrollButtonDown 
  230.         tkScrollButtonUp tkScrollByPages tkScrollByUnits tkScrollDrag 
  231.         tkScrollEndDrag tkScrollSelect tkScrollStartDrag tkScrollToPos 
  232.         tkScrollTopBottom tkTabToWindow tkTearOffMenu tkTextAutoScan 
  233.         tkTextButton1 tkTextClosestGap tkTextInsert tkTextKeyExtend 
  234.         tkTextKeySelect tkTextNextPara tkTextNextPos tkTextNextWord 
  235.         tkTextPaste tkTextPrevPara tkTextPrevPos tkTextResetAnchor 
  236.         tkTextScrollPages tkTextSelectTo tkTextSetCursor 
  237.         tkTextTranspose tkTextUpDownLine tkTraverseToMenu 
  238.         tkTraverseWithinMenu tk_bisque tk_chooseColor tk_dialog 
  239.         tk_focusFollowsMouse tk_focusNext tk_focusPrev tk_getOpenFile 
  240.         tk_getSaveFile tk_messageBox tk_optionMenu tk_popup 
  241.         tk_setPalette tk_textCopy tk_textCut tk_textPaste
  242.     }
  243.     }
  244.     
  245.     if {$TclmodeVars(recogniseTk)} {
  246.     regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
  247.       -s $TclmodeVars(stringColor) \
  248.       -k $TclmodeVars(keywordColor) Tcl $tclKeyWords 
  249.     # add this line if we can handle double 'magic chars'
  250.     #-m {tk} 
  251.     } else {
  252.     regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
  253.       -s $TclmodeVars(stringColor) \
  254.       -k $TclmodeVars(keywordColor) Tcl $tclKeyWords 
  255.     }
  256.     if {$TclmodeVars(alphaKeyWordColor) != "none"} {
  257.     regModeKeywords -a -k $TclmodeVars(alphaKeyWordColor) Tcl $alphaKeyWords
  258.     }
  259. }
  260. # call it now
  261. Tcl::_updateKeywords
  262.  
  263. proc Tcl::MenuProc {menu item} {
  264.     switch -glob $item {
  265.     "traceThisProc" {
  266.         procs::traceProc [procs::findEnclosingName [getPos]]
  267.     }
  268.     "reformatProc" {
  269.         procs::reformatEnclosing [getPos]
  270.     }
  271.     "reloadProc" {
  272.         procs::loadEnclosing [getPos]
  273.     }
  274.     "findProcDefinition" {
  275.         procs::findDefinition
  276.     }
  277.     "quickFindProc" {
  278.         # use the status line
  279.         procs::quickFindDefn
  280.     }
  281.     "switch*" {
  282.         set v "[string tolower [string range $item 8 end]]Sig"
  283.         global $v
  284.         app::launchFore [set $v]
  285.     }
  286.     "addRemoveDollars" {
  287.         togglePrefix \$
  288.     }
  289.     default {
  290.         uplevel \#0 $item
  291.     }
  292.     }
  293. }
  294. namespace eval tcltk {}
  295.  
  296. proc tcltk::menuProc {menu item} {
  297.     switch -- $item {
  298.     "evaluateRemotely" {
  299.         global evaluateRemotely
  300.         set evaluateRemotely [expr {1 - $evaluateRemotely}]
  301.     }
  302.     default {
  303.         global tclshSig
  304.         set cmd [getline "Please enter the script to send to tcl-tk"]
  305.         if {$cmd == ""} {return}
  306.         if {$tcl_platform(platform) == "macintosh"} {
  307.         set res [AEBuild -r -t 30000 '$tclshSig' misc dosc ---- "“$cmd”"]
  308.         } else {
  309.         set res [tcltk::evaluate $cmd]
  310.         }
  311.         alertnote "Result was '$res'"
  312.     }
  313.     }
  314. }
  315.  
  316. proc evaluateRemoteSynchronise {args} {
  317.     global evaluateRemotely tclMenu
  318.     catch {markMenuItem "tcl-tk" evaluateRemotely $evaluateRemotely}
  319.     if {$evaluateRemotely} {
  320.     if {[info commands notRemoteEvaluate] == ""} {
  321.         rename evaluate notRemoteEvaluate
  322.         ;proc evaluate {} {remoteEvaluate}
  323.     }
  324.     menu::replaceRebuild tclMenu "•320"
  325.     } else {
  326.     if {[info commands notRemoteEvaluate] != ""} {
  327.         rename evaluate {}
  328.         rename notRemoteEvaluate evaluate
  329.     }
  330.     menu::replaceRebuild tclMenu "•269"
  331.     }
  332. }
  333.  
  334.  
  335. proc remoteEvaluate {} {
  336.     message "Remote reply: [tcltk::evaluate [getSelect]]"
  337. }
  338.  
  339. proc tcltk::evaluate {what} {
  340.     global tclshSig tcl_platform
  341.     if {$tcl_platform(platform) == "macintosh"} {
  342.     app::ensureRunning $tclshSig
  343.     set r [AEBuild -r -t 30000 '${tclshSig}' misc dosc ---- "“$what”"]
  344.     set r [lindex [aeparse::event $r] 2]
  345.     if {[lindex [lindex $r 0] 0] == "errs"} {
  346.         set res "Error: "
  347.     }
  348.     append res [aeparse::TEXT [aeparse::keywordValue [lindex $r 0] $r]]
  349.     #catch {dosc -c '${tclshSig}' -s $what} res
  350.     } else {
  351.     global tclshInterp
  352.     if {![info exists tclshInterp]} {
  353.         if {[catch {tcltk::findTclshInterp}]} {
  354.         return "No shell selected"
  355.         }
  356.     }
  357.     if {$tcl_platform(platform) == "windows"} {
  358.         if {[dde services Tk $tclshInterp] == ""} {
  359.         alertnote "The remove shell has died, please select a new one."
  360.         unset tclshInterp
  361.         return [tcltk::evaluate $what]
  362.         }
  363.         catch {dde execute Tk $tclshInterp $what} res
  364.     } else {
  365.         catch {send $tclshInterp $what} res
  366.     }
  367.     }
  368.     return $res
  369. }
  370.  
  371. proc tcltk::findTclshInterp {} {
  372.     global tclshInterp tclshSigs tclshSig
  373.     set shel [listpick -p "Use which Tcl shell?" [concat [winfo interps] \
  374.       [list "------------------" "Launch new shell"]]]
  375.     if {$shel == "Launch new shell"} {
  376.     set old [winfo interps]
  377.     app::launchElseTryThese $tclshSigs tclshSig "Please locate the remote Tcl application"
  378.     launch -f $tclshSig
  379.     while {[winfo interps] == $old} {
  380.         update
  381.     }
  382.     set tclshInterp [lremove -l [winfo interps] $old]
  383.     # We're left with two items
  384.     set tclshInterp [lindex $tclshInterp 0]
  385.     } else {
  386.     set tclshInterp $shel
  387.     }
  388. }
  389.  
  390. # ◊◊◊◊ Quick Find Proc… ◊◊◊◊ #
  391.  
  392. proc procs::quickFindDefn {} {
  393.     Tcl::DblClickHelper [prompt::statusLineComplete "proc" procs::complete]
  394. }
  395.  
  396. if {[info tclversion] < 8.0} {
  397.     proc procs::complete {pref} {
  398.     return [info commands ${pref}*]
  399.     }
  400. } else {
  401.     proc procs::complete {pref} {
  402.     if {[regexp {(.*)([^:]+)$} $pref "" start tail]} {
  403.         set cmds [info commands ${pref}*]
  404.         foreach child [namespace children ::$start] {
  405.         if {[string match "::${tail}*" $child]} {
  406.             foreach cmd [info commands ${start}${child}::*] {
  407.             lappend cmds [string trimleft $cmd :]
  408.             }
  409.         }
  410.         }
  411.         return $cmds
  412.     } else {
  413.         return [info commands ${pref}*]
  414.     }
  415.     }
  416. }
  417.  
  418. # ◊◊◊◊ electric behaviour ◊◊◊◊ #
  419. proc Tcl::electricLeft {} {
  420.     if {[literalChar]} { insertText "\{"; return }
  421.     set pat "\}\[ \t\r\n\]*(else(if)?)\[ \t\r\n\]*\$"
  422.     set p [getPos]
  423.     if { [set res [findPatJustBefore "\}" "$pat" $p word]] == "" } { 
  424.     insertText "\{"
  425.     return
  426.     }
  427.     # we have an if/else(if)/else
  428.     switch -- $word {
  429.     "else" {
  430.         replaceText [lindex $res 0] $p "\} $word \{\r"
  431.         bind::IndentLine
  432.     }
  433.     "elseif" {
  434.         replaceText [lindex $res 0] $p "\} $word \{"
  435.     }
  436.     }
  437. }
  438.     
  439. proc Tcl::electricRight {} {
  440.     if {[literalChar]} { insertText "\}"; return }
  441.     set p [getPos]
  442.     if { [regexp "\[^ \t\]" [getText [lineStart $p] $p]] } {
  443.     insertText "\}"
  444.     blink [matchIt "\}" [pos::math $p - 1]]
  445.     return
  446.     }
  447.     set start [lineStart $p]
  448.     insertText "\}"
  449.     createTMark tcl_er [getPos]
  450.     backwardChar
  451.     bind::IndentLine
  452.     gotoTMark tcl_er ; removeTMark tcl_er
  453.     bind::CarriageReturn
  454.     blink [matchIt "\}" [pos::math $start - 1]]
  455. }
  456.  
  457. ## 
  458.  # -------------------------------------------------------------------------
  459.  # 
  460.  # "Tcl::correctIndentation" --
  461.  # 
  462.  #  Returns the correct indentation for the line containing $pos, if that
  463.  #  line were to contain ordinary characters only.  It is the 
  464.  #  responsibility of the calling procedure to ensure that if we are to
  465.  #  insert/have a line already, that that information is taken into
  466.  #  account, by passing in the argument 'next'
  467.  # -------------------------------------------------------------------------
  468.  ##
  469. proc Tcl::correctIndentation {pos {next ""}} {
  470.     global indent_amounts indentSlashEndLines
  471.     # preliminaries
  472.     if {[pos::compare [set beg [lineStart $pos]] == [minPos]]} { return 0 }
  473.     # if the current line is a comment, we have to check some
  474.     # special cases
  475.     if {[string index $next 0] == "\#"} {
  476.     set p [prevLineStart $beg]
  477.     if {[catch {set p [search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^ \t\r\n\]" \
  478.       [pos::math $beg - 1]]}]} {
  479.         # check for search bug at beginning of file.
  480.         if {[pos::compare $p == [minPos]]} {
  481.         if {[getText [minPos] [pos::math [minPos] + 2]] == "\#\#"} {
  482.             if {([string range $next 0 1] != "\#\#")} {
  483.             return 1
  484.             } else {
  485.             return 0
  486.             }
  487.         }
  488.         }
  489.         return 0
  490.     }
  491.     set prev [pos::math [lindex $p 1] - 1]
  492.     set p [lindex $p 0]
  493.     if {[lookAt $prev] != "\#" || ($beg == [minPos])} {
  494.         # not a comment, so indent with code
  495.     } else {
  496.         set lwhite [posX $prev]
  497.         # it's a comment
  498.         if {[getText $prev [pos::math $prev + 2]] == "\#\#" && \
  499.           [lookAt [pos::math $prev + 2]] != "\#" \
  500.           && ([string range $next 0 1] != "\#\#")} {
  501.         # it's a comment paragraph
  502.         incr lwhite 
  503.         }
  504.     }
  505.     }
  506.     set next [string index $next 0]
  507.     if {![info exists lwhite]} {
  508.     if {![catch {search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^\# \t\r\n\]" [pos::math $beg - 1]} lst]} {
  509.         # Find the last non-comment line and get its leading whitespace    
  510.         set lwhite [posX [pos::math [lindex $lst 1] - 1]]
  511.         set pe1 [lookAt [pos::math $beg - 2]]
  512.         set lst [lindex $lst 0]
  513.         set lastC [lookAt [lindex [search -s -f 0 -r 1 -i 0 -m 0 "\[^ \t\r\n\]" [pos::math [nextLineStart $lst] - 1]] 0]]
  514.         if {$next == "\}"} {
  515.         incr lwhite $indent_amounts(-2)
  516.         set pe2 [lookAt [pos::math [prevLineStart $beg] - 2]]
  517.         if {$pe1 == "\\"} {
  518.             incr lwhite $indent_amounts(1)
  519.         } else {
  520.             if {$pe2 == "\\"} {
  521.             incr lwhite $indent_amounts(-1)
  522.             }
  523.         }
  524.         if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  525.         } else { 
  526.         if {$pe1 == "\\"} {
  527.             if {[lookAt [pos::math [prevLineStart $beg] - 2]] != "\\"} {
  528.             incr lwhite $indent_amounts($indentSlashEndLines)
  529.             }
  530.         } else {
  531.             if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  532.             if {[lookAt [pos::math $lst - 2]] == "\\"} {
  533.             incr lwhite $indent_amounts(-$indentSlashEndLines)
  534.             }
  535.         }
  536.         }
  537.     } else {
  538.         # basically failed in all the above, so keep current indentation
  539.         set lwhite [posX [text::firstNonWsLinePos $beg]]
  540.     }
  541.     }
  542.     return [expr {$lwhite > 0 ? $lwhite : 0}]
  543. }
  544.  
  545. ## 
  546.  # -------------------------------------------------------------------------
  547.  #   
  548.  # "Tcl::indentLine" --
  549.  #  
  550.  #  Indentation for Tcl mode.  Better and faster than the generic procedure
  551.  # -------------------------------------------------------------------------
  552.  ##
  553. proc Tcl::indentLine {} {
  554.     set beg [lineStart [getPos]]
  555.     set text [getText $beg [nextLineStart $beg]]
  556.     regexp "^\[ \t\]*" $text white
  557.     set next [pos::math $beg + [string length $white]]
  558.     set lwhite [Tcl::correctIndentation [getPos] [getText $next [pos::math $next + 2]]]
  559.     
  560.     set lwhite [text::indentOf $lwhite]
  561.     if {$white != $lwhite} {
  562.     replaceText $beg $next $lwhite
  563.     }
  564.     goto [pos::math $beg + [string length $lwhite]]
  565. }
  566. # ◊◊◊◊ Tcl Menu support ◊◊◊◊ #
  567.  
  568. proc procs::reformatEnclosing {pos} {
  569.     set p [procs::findEnclosing $pos "proc|body|configbody" 1]
  570.     eval select $p
  571.     ::indentRegion
  572. }
  573.  
  574. proc procs::loadEnclosing {pos} {
  575.     if {[catch {procs::findEnclosing $pos "proc|body|configbody" 1} p]} {
  576.     evaluateLine $pos
  577.     } else {
  578.     eval select $p
  579.     uplevel \#0 evaluate    
  580.     }
  581.     goto $pos
  582. }
  583.  
  584. proc procs::findDefinition {} {
  585.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  586.     set func [listpick -L $sel -p {Proc?} [lsort -ignore [info procs]]]
  587.     } else {
  588.     set func [listpick -p {Proc?} [lsort -ignore [info procs]]]
  589.     }
  590.     
  591.     editMark [procs::find $func] $func
  592. }
  593.  
  594. proc insertMenuCodes {} {
  595.     insertText [prompt::getAKey]
  596. }
  597.  
  598. proc insertBindingCodes {} {
  599.     beep
  600.     keyCode
  601. }
  602.  
  603.  
  604. ## 
  605.  # -------------------------------------------------------------------------
  606.  # 
  607.  # "insertDivider" --
  608.  # 
  609.  #  Modified from Vince's original to allow you to just select part of
  610.  #  an already written comment and turn it into a Divider. -trf
  611.  # -------------------------------------------------------------------------
  612.  ##
  613. proc insertDivider {} {
  614.     if {[isSelection]} {
  615.     set enfoldThis [getSelect]
  616.     beginningOfLine
  617.     killLine
  618.     insertText "# ◊◊◊◊ $enfoldThis ◊◊◊◊ #"
  619.     return
  620.     } 
  621.     elec::Insertion "# ◊◊◊◊ •• ◊◊◊◊ #"
  622. }
  623.  
  624. # vince's versions seems to have been left out, so here's mine -trf
  625. # If there is a selection, it get surrounded, if there is no selection,
  626. # but the cursor is touching the end of a word, it gets surrounded. 
  627. # Otherwise, we get a template (could not come up with a "stop beyond")
  628. proc surroundWithBullets {} {
  629.     if {[pos::compare [getPos] == [selEnd]]} {
  630.     set p [getPos]
  631.     backwardWord 
  632.     set sw [getPos]
  633.     forwardWord 
  634.     set ew [getPos]
  635.     goto $p
  636.     if {[pos::compare $p == $ew]} {
  637.         select $sw $ew
  638.     } 
  639.     }
  640.     if {[isSelection]} {
  641.     set enfoldThis [getSelect]
  642.     deleteSelection
  643.     insertText "•$enfoldThis•"
  644.     return
  645.     } 
  646.     insertText "••"
  647.     backwardChar
  648.     elec::Insertion "•replace-this•"
  649. }
  650. # ◊◊◊◊ Info providers ◊◊◊◊ #
  651. #===============================================================================
  652.  
  653. ## 
  654.  # -------------------------------------------------------------------------
  655.  # 
  656.  # "TclOptionTitlebar" --
  657.  # 
  658.  #  Add corresponding extension/non-extension files.
  659.  # -------------------------------------------------------------------------
  660.  ##
  661. proc Tcl::OptionTitlebar {} {
  662.     if {[package::active smarterSource]} {
  663.     set n [win::CurrentTail]
  664.     if {[set a [string first + $n]] != -1} {
  665.         return "[string range $n 0 [expr {$a -1}]][file extension $n]"
  666.     } else {
  667.         global tclExtensionsFolder
  668.         pushd $tclExtensionsFolder
  669.         set f [glob -nocomplain "[file root $n]+*[file extension $n]"]
  670.         popd
  671.         return $f
  672.     }
  673.     } else {
  674.     return ""
  675.     }
  676. }
  677.  
  678. proc Tcl::DblClick {from to shift option control} {
  679.     
  680.     # if cmd and cntrl were pressed, we look to select part of
  681.     # a combination word (less any leading dollar sign) -trf
  682.     if {$control != 0} {
  683.     set clickedPos [getPos]    
  684.     if {[lookAt $from] == "\$"} {
  685.         set from [pos::math $from + 1]
  686.     } 
  687.     set sel_start $clickedPos 
  688.     set selStartNotDetermined 1
  689.     while {$selStartNotDetermined && ([pos::math $sel_start > $from])} {
  690.         set char [lookAt $sel_start] 
  691.         if {[regexp {_} $char]} {
  692.         set sel_start [pos::math $sel_start + 1]
  693.         set selStartNotDetermined 0
  694.         } elseif {[regexp {[A-Z]} $char]} {
  695.         set selStartNotDetermined 0
  696.         } else {
  697.         set sel_start [pos::math $sel_start -1]
  698.         } 
  699.     }
  700.     set sel_end   $clickedPos 
  701.     set selEndNotDetermined 1
  702.     while {$selEndNotDetermined && ([pos::math $sel_end <= $to])} {
  703.         set char [lookAt $sel_end] 
  704.         if {[regexp "\[A-Z_ \t\r\]" $char]} {
  705.         set selEndNotDetermined 0
  706.         } else {
  707.         set sel_end [pos::math $sel_end + 1]
  708.         } 
  709.     }
  710.     select $sel_start $sel_end 
  711.     return
  712.     } 
  713.     
  714.     # otherwise, we try to impart some extra info
  715.     select $from $to
  716.     
  717.     if {[catch {Tcl::DblClickHelper [getSelect]}]} {
  718.     message "No docs $shift $control $option"
  719.     }
  720. }
  721.  
  722.  
  723. # Now finds commands in Alpha Commands,
  724. # which has a <cr> immediately after them, e.g. beep, ticks.
  725. proc Tcl::DblClickHelper {text} {
  726.     global HOME auto_index auto_path
  727.     # Is it a loadable proc?
  728.     if {[string length [set f [procs::find $text]]]} {
  729.     if {[editMark $f $text]} {
  730.         # some marking schemes commonly used for Tcl modes
  731.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  732.     }
  733.     return
  734.     }
  735.     
  736.     if {[info exists "auto_index($text)"]} {
  737.     if {[editMark "$auto_index($text)" $text]} {
  738.         # some marking schemes commonly used for Tcl modes
  739.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  740.     }
  741.     return
  742.     }
  743.     # Is it a built-in Alpha command?
  744.     set lines [grep "^• $text\( |\$)" [file join $HOME Help "Alpha Commands"]]
  745.     if {[string length $lines]} {
  746.     if {[catch {editMark [file join $HOME Help "Alpha Commands"] $text}]} {
  747.         # mark failed for some reason, but we have the line number
  748.         # anyway.
  749.         file::openQuietly [file join $HOME Help "Alpha Commands"]
  750.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  751.     }
  752.     setWinInfo read-only 1
  753.     return
  754.     }
  755.     # Is it a core Tcl command?
  756.     set lines [grep "^     $text -" [file join $HOME Help "Tcl Commands"]]
  757.     if {[string length $lines]} {
  758.     if {[catch {editMark [file join $HOME Help "Tcl Commands"] $text}]} {
  759.         # mark failed for some reason, but we have the line number
  760.         # anyway.
  761.         file::openQuietly [file join $HOME Help "Tcl Commands"]
  762.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  763.     }
  764.     setWinInfo read-only 1
  765.     return
  766.     }
  767.     # Is it a global variable?
  768.     if {[llength [info globals [string trimleft $text {$}]]]==1} {
  769.     showVarValue [string trimleft $text {$}]
  770.     return
  771.     }
  772.     # (becoming desperate) is it a mark in the current file?
  773.     if {[lsearch [getNamedMarks -n] ${text}] != -1} {
  774.     gotoMark $text
  775.     return
  776.     }
  777.     error ""
  778. }
  779.  
  780. #############################################################################
  781. #  Report the current value of a global variable, chosen interactively
  782. #  from a list of all active variables.
  783. #
  784. #  If the variable is an array, or its value is too big to fit in an 
  785. #  alertnote, then its contents are listed in a new window, otherwise 
  786. #  the variable's value is displayed in an alertnote.
  787. #
  788. proc getVarValue {} {
  789.     set def [getText [getPos] [selEnd]]
  790.     set var [getVarFromList $def]
  791.     if {[string length $var] == 0} return
  792.     showVarValue $var
  793. }
  794.  
  795. if {[info tclversion] < 8.0} {
  796.     
  797.     proc getVarFromList {{def ""}} {
  798.     return [listpick -p {Which var?} -L $def [lsort -ignore [info globals]]]
  799.     }
  800.     
  801. } else {
  802.     
  803.     proc getVarFromList {{def ""}} {
  804.     set ns "[namespace qualifiers $def]"
  805.     set def [namespace tail $def]
  806.     
  807.     set items {}
  808.     foreach var [info vars "${ns}::*"] {
  809.         lappend items [namespace tail $var]
  810.     }
  811.     foreach space [namespace children $ns] {
  812.         lappend items "[namespace tail $space]::"
  813.     }
  814.     
  815.     set items [concat "::" [lsort -ignore $items]]
  816.     set var [listpick -p "Which var in namespace ${ns}::?" -L $def $items]
  817.     if {$var == "::"} {
  818.         set var [getVarFromList $ns]
  819.     } elseif {[namespace qualifiers $var] != ""} {
  820.         set var [getVarFromList "${ns}::${var}"]
  821.     } else {
  822.         set var "${ns}::${var}"
  823.     }
  824.     return $var
  825.     }
  826. }
  827.  
  828. #############################################################################
  829. #  Report the current value of a global variable, chosen interactively
  830. #  from a list of all active variables.
  831. #
  832. #  If the variable is an array, or its value is too big to fit in an 
  833. #  alertnote, then its contents are listed in a new window, otherwise 
  834. #  the variable's value is displayed in an alertnote.
  835. #
  836. proc showVarValue {var} {
  837.     global $var
  838.     if {![array exists $var]} {
  839.         viewValue $var [set $var]
  840.     } else {
  841.     new -n "* $var *" -info [listArray $var]
  842.     # if 'shrinkWindow' is loaded, call it to trim the output window.
  843.     catch {shrinkWindow 2}
  844.     }
  845. } 
  846.  
  847. #############################################################################
  848. #  List the name and value of each element of the array $arrName.
  849. #  (Convenient to use as a shell command.)
  850. #
  851. proc listArray {arrName} {
  852.     global $arrName
  853.     if {[array exists $arrName]} {
  854.     set lines {}
  855.         foreach nm [array names $arrName] {
  856.             lappend lines "\"$nm\"\t\{[set ${arrName}($nm)]\}"
  857.         }
  858.         return [join $lines \r]
  859.     } else {
  860.         alertnote "\"$arrName\" doesn't exist in this context"
  861.     }
  862. }
  863.  
  864. # ◊◊◊◊ Marking ◊◊◊◊ #
  865.  
  866. ## 
  867.  # -------------------------------------------------------------------------
  868.  #     
  869.  # "Tcl::parseFuncs" --
  870.  #    
  871.  # This proc is called by the "braces"    pop-up.    It returns a dynamically
  872.  # created, alphabetical, list of "pseudo-marks".
  873.  #    
  874.  #    Author:    Tom Fetherston
  875.  # -------------------------------------------------------------------------
  876.  ## called by the "{}" button
  877. proc Tcl::parseFuncs {} {
  878.     global TclmodeVars
  879.     set end [maxPos]
  880.     set pos [minPos]
  881.     set l {}
  882.     set markExpr "^\[ \t\]*((itcl(::|_))?class|body|proc|method|body)\[ \t\]"
  883.     set appearanceList {}
  884.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  885.     set start [lindex $res 0]
  886.     set end [nextLineStart $start]
  887.     set t [getText $start $end]
  888.     append t "\}"
  889.     set argLabel {}
  890.     switch -- [lindex $t 0] {
  891.         "proc" {
  892.         append argLabel [set word [lindex $t 1]]
  893.         #get the list of arguments
  894.         set argsList [lindex $t 2]
  895.         if {[llength $argsList] > 0} {
  896.             append argLabel " \{"
  897.             foreach arg $argsList {
  898.             if {[llength $arg] == 2 } {
  899.                 append argLabel "¿"
  900.             } elseif {[set arg] != "args"} {
  901.                 append argLabel "•"
  902.             } else {
  903.                 append argLabel "…"
  904.             }
  905.             }
  906.             append argLabel "\}"                    
  907.         } 
  908.         }
  909.         default {
  910.         append argLabel [set word [lindex $t 1]]
  911.         }
  912.     }
  913.     if {[info exists cnts($word)]} {
  914.         # This section handles duplicate. i.e., overloaded names
  915.         set cnts($word) [expr {$cnts($word) + 1}]
  916.         set tailOfTag($word) " ($cnts($word) of $cnts($word))"
  917.         # we want the tag to point to its last occurence 
  918.         # because in Tcl, that proc will be 'in-force' when the
  919.         # file is loaded.
  920.         set indx($word) [lineStart [pos::math $start - 1]]
  921.     } else {
  922.         #SO do: remember the following
  923.         set cnts($word) 1
  924.         # if this is the only occurence of this proc, remember where it starts
  925.         set indx($word) [lineStart [pos::math $start - 1]]
  926.     }
  927.     #associate name and tag
  928.     set tag($word) $argLabel
  929.     
  930.     #advance pos to where we want to start the next search from
  931.     set pos $end
  932.     }
  933.     
  934.     set rtnRes {}
  935.     
  936.     if {[info exists indx]} {
  937.     foreach hn [lsort -ignore [array names indx]] {
  938.         set next [nextLineStart $indx($hn)]
  939.         set completeTag [set tag($hn)]
  940.         if {[info exists tailOfTag($hn)]} {
  941.         append completeTag [set tailOfTag($hn)]
  942.         }
  943.         
  944.         lappend rtnRes $completeTag $next
  945.     }
  946.     }
  947.     return $rtnRes 
  948. }
  949.  
  950. # called by the "M" button
  951. proc Tcl::MarkFile {} {
  952.     global structuralMarks
  953.     set end [maxPos]
  954.     set pos [minPos]
  955.     set l {}
  956.     if {$structuralMarks} {
  957.     set markExpr {^;?[     ]*((itcl(::|_))?class|namespace eval|proc|method|(config)?body|# ◊◊◊◊)[     ]}
  958.     } else {
  959.     set markExpr {^;?[     ]*((itcl(::|_))?class|namespace eval|proc|method|(config)?body)[     ]}
  960.     }
  961.     set class ""
  962.     set hasMarkers 0
  963.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  964.     set start [lindex $res 0]
  965.     set end [nextLineStart $start]
  966.     set t [string trim [getText $start $end] ";"]
  967.     append t "\}"
  968.     if {[catch {lindex $t 0}]} {
  969.         # wasn't a well formed list
  970.         set pos $end
  971.         continue
  972.     }
  973.     switch -glob [lindex $t 0] {
  974.         "proc" -
  975.         "configbody" { set text [lindex $t 1] }
  976.         "method" { set text ${class}::[lindex $t 1] }
  977.         "body" { 
  978.         regexp {[a-zA-Z_][a-zA-Z_/0-9]*::[a-zA-Z_][a-zA-Z_/0-9]* } \
  979.           "[lindex $t 1] " text
  980.         }
  981.         "namespace" {
  982.         set ns [lindex $t 2]
  983.         set text "${ns} 111" 
  984.         }
  985.         "*class" { 
  986.         set class [lindex $t 1]
  987.         set text "${class} 000" 
  988.         }
  989.         "#" { 
  990.         regexp "# ◊◊◊◊ (.*) ◊◊◊◊" $t all text
  991.         if {[regexp "^(    )|(    )# ◊◊◊◊ " $t]} {
  992.             set text " •$text"
  993.         } else {
  994.             set text "•$text"
  995.         }                
  996.         set hasMarkers 1
  997.         }
  998.     }
  999.     set pos $end
  1000.     if {$structuralMarks} {
  1001.         lappend asEncountered $text
  1002.         set arr inds
  1003.     } else {
  1004.         if {[string index $t 0] == ";"} {
  1005.         set arr iinds
  1006.         } else {
  1007.         set arr inds
  1008.         }
  1009.     }
  1010.     set ${arr}($text) [lineStart [pos::math $start - 1]]
  1011.     }
  1012.     
  1013.     set already ""
  1014.     set class "#"
  1015.     foreach arr {inds iinds} {
  1016.     if {[info exists $arr]} {
  1017.         if {$arr == "iinds"} {
  1018.         setNamedMark "-" 0 0 0
  1019.         }
  1020.         if {$structuralMarks} {
  1021.         set order $asEncountered
  1022.         } else {
  1023.         set order [lsort -ignore [array names $arr]]
  1024.         }
  1025.         foreach f $order {
  1026.         if {[set el [set ${arr}($f)]] != 0} {
  1027.             set next [nextLineStart $el]
  1028.         } else {
  1029.             set next 0
  1030.         } 
  1031.         
  1032.         if { [string first "000" $f] != -1 } {
  1033.             set ff "Class '[set class [lindex $f 0]]'"
  1034.         } elseif { [string first "111" $f] != -1 } {
  1035.             set ff "Namespace '[set class [lindex $f 0]]'"
  1036.         } elseif { [string first "${class}::" $f] == 0 } {
  1037.             set ff [string range $f [string length $class] end]
  1038.         } else {
  1039.             set ff $f
  1040.         }
  1041.         while { [lsearch -exact $already $ff] != -1 } {
  1042.             set ff "$ff "
  1043.         }
  1044.         lappend already $ff
  1045.         if {$hasMarkers && ![string match "•*" $ff] } {
  1046.             set ff " $ff"
  1047.         } 
  1048.         setNamedMark $ff $el $next $next
  1049.         }
  1050.     }
  1051.     }
  1052. }
  1053.  
  1054. # ◊◊◊◊ Misc. ◊◊◊◊ #
  1055.  
  1056. ## 
  1057.  # -------------------------------------------------------------------------
  1058.  # 
  1059.  # "bind::tclContinueComment" --
  1060.  # 
  1061.  #  exploits a "feature" in the code that makes a new line a comment whenever 
  1062.  #  you are 'inside' a comment. This proc puts a pound sign at the end of the 
  1063.  #  current line, backsteps, and creates a new line. With the pound sign 
  1064.  #  present you are considered to be in a comment, so the bind::CarriageReturn 
  1065.  #  in the proc, and any subsequent bind::CarriageReturn called by a press of  
  1066.  #  the return key will provide another comment line automatically until the 
  1067.  #  pound sign at the end of the line is removed (killLine is handy for this).
  1068.  # -------------------------------------------------------------------------
  1069.  ##
  1070. proc bind::tclContinueComment {} {
  1071.     insertText {#}
  1072.     backwardChar
  1073.     bind::CarriageReturn
  1074.     deleteChar
  1075. }
  1076. Bind '\r' <c> bind::tclContinueComment Tcl
  1077.  
  1078. proc evaluateLine { pos } {
  1079.     goto $pos
  1080.     beginningLineSelect
  1081.     endLineSelect
  1082.  
  1083.     uplevel \#0 evaluate
  1084. }
  1085.  
  1086. #◊◊◊◊> 
  1087.  
  1088. evaluateRemoteSynchronise
  1089.  
  1090.